We model a decision impact pathway is for school gardens as a general intervention for sustainable children’s food environments in urban Hanoi, Vietnam (Whitney et al. 2024).
Conceptual model of school gardens as an intervention. Should urban Hanoi school boards invest time and money in creating school gardens? Should they invest in formal STEM education as part of these gardens?
Simulation of the school garden intervention options:
# Source our model
source("Garden_Model.R")
# Ensure consistent results with the random number generator
# not for each 'run' of the MC simulation but for
# consistency each time we run the entire simulation
set.seed(42)
garden_simulation_results <- mcSimulation(
estimate = estimate_read_csv("data/inputs_school_garden.csv"),
model_function = school_garden_function,
numberOfModelRuns = 1e4, #run 10,000 times
functionSyntax = "plainNames"
)
The Net Present Value (i.e. current value of the future benefits) of the garden decision options over 5 years of the intervention. For public and private schools the STEM costs are considered to be in the same garden space but with the additional costs and benefits of a full STEM education program. All options are compared to the same years of using the land for something that is not related to the garden, i.e. as a playground or for parking. Here we plot the distribution for the decision and frame the projected NPV.
For public schools:
source("functions/plot_distributions.R")
plot_distributions(mcSimulation_object = garden_simulation_results,
vars = c("NPV_garden_public_school_inclusive",
"NPV_garden_STEM_public_school_inclusive"),
old_names = c("NPV_garden_public_school_inclusive", "NPV_garden_STEM_public_school_inclusive"),
new_names = c("NPV public school passive garden", "NPV public school STEM garden"),
method = 'smooth_simple_overlay',
base_size = 7,
x_axis_name = "Comparative NPV outcomes")
For private schools:
source("functions/plot_distributions.R")
plot_distributions(mcSimulation_object = garden_simulation_results,
vars = c("NPV_garden_inclusive","NPV_garden_STEM_inclusive"),
old_names = c("NPV_garden_inclusive","NPV_garden_STEM_inclusive"),
new_names = c("NPV private school passive garden","NPV private school STEM garden"),
method = 'smooth_simple_overlay',
base_size = 7,
x_axis_name = "Comparative NPV outcomes")
The same results again but this time as boxplots:
source("functions/plot_distributions.R")
plot_distributions(mcSimulation_object = garden_simulation_results,
vars = c("NPV_garden_inclusive","NPV_garden_STEM_inclusive", "NPV_garden_public_school_inclusive", "NPV_garden_STEM_public_school_inclusive"),
old_names = c("NPV_garden_inclusive","NPV_garden_STEM_inclusive", "NPV_garden_public_school_inclusive", "NPV_garden_STEM_public_school_inclusive"),
new_names = c("NPV private school passive garden","NPV private school STEM garden", "NPV public school passive garden", "NPV public school STEM garden"),
method = "boxplot",
base_size = 11,
x_axis_name = "Comparative NPV outcomes (million VND)")
ggsave("figures/Fig_5_Boxplots.png", width = 15, height = 8, units = "cm")
As boxplots and distributions for public schools:
source("functions/plot_distributions.R")
plot_distributions(mcSimulation_object = garden_simulation_results,
vars = c("NPV_garden_public_school_inclusive", "NPV_garden_STEM_public_school_inclusive"),
old_names = c("NPV_garden_public_school_inclusive", "NPV_garden_STEM_public_school_inclusive"),
new_names = c("NPV public school garden", "NPV public school garden with STEM"),
method = "boxplot_density",
base_size = 7,
x_axis_name = "Comparative NPV outcomes")
As boxplots and distributions for private schools:
source("functions/plot_distributions.R")
plot_distributions(mcSimulation_object = garden_simulation_results,
vars = c("NPV_garden_inclusive","NPV_garden_STEM_inclusive"),
old_names = c("NPV_garden_inclusive","NPV_garden_STEM_inclusive"),
new_names = c("NPV private school garden","NPV private school with STEM"),
method = "boxplot_density",
base_size = 7,
x_axis_name = "Comparative NPV outcomes")
Summary of the NPVs for the passive education garden and STEM options for private schools:
summary(garden_simulation_results$y[1:2]) #"NPV_garden_inclusive" "NPV_garden_STEM_inclusive"
## NPV_garden_inclusive NPV_garden_STEM_inclusive
## Min. :-1005 Min. :-3531.5
## 1st Qu.: 722 1st Qu.: 219.8
## Median : 1413 Median : 904.2
## Mean : 1668 Mean : 1106.9
## 3rd Qu.: 2327 3rd Qu.: 1783.8
## Max. :11176 Max. :11145.9
Summary of the NPVs for the passive education garden and STEM options for public schools:
summary(garden_simulation_results$y[3:4]) #"NPV_garden_public_school_inclusive" "NPV_garden_STEM_public_school_inclusive"
## NPV_garden_public_school_inclusive NPV_garden_STEM_public_school_inclusive
## Min. :-1005.2 Min. :-3531.5
## 1st Qu.: -221.7 1st Qu.: -265.3
## Median : 537.1 Median : -125.1
## Mean : 910.1 Mean : 431.1
## 3rd Qu.: 1643.5 3rd Qu.: 911.7
## Max. : 8301.3 Max. : 7432.2
Summary of the child health outcomes for private and public schools:
summary(garden_simulation_results$y[10:11]) #"health" "health_STEM"
## health health_STEM
## Min. : 0.0 Min. : 0.0
## 1st Qu.: 269.9 1st Qu.: 248.3
## Median : 688.4 Median : 567.7
## Mean : 749.2 Mean : 583.6
## 3rd Qu.:1094.9 3rd Qu.: 859.2
## Max. :5242.5 Max. :3290.4
Summary of the biodiversity outcomes for the passive education garden and STEM options for private and public schools:
summary(garden_simulation_results$y[9]) #"biodiversity"
## biodiversity
## Min. : 0.000
## 1st Qu.: 3.815
## Median :10.023
## Mean :10.118
## 3rd Qu.:15.098
## Max. :55.364
Total expected costs for a school garden with and without STEM education:
summary(garden_simulation_results$y[12:13])
## total_costs total_costs_STEM
## Min. : 87.33 Min. : 143.1
## 1st Qu.: 199.98 1st Qu.: 357.2
## Median : 435.41 Median : 839.6
## Mean : 398.83 Mean : 929.8
## 3rd Qu.: 514.87 3rd Qu.:1252.3
## Max. :1474.13 Max. :5011.9
First year expected costs for a school garden:
summary(garden_simulation_results$y$Cashflow_garden1)
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## -606.721 -95.383 8.306 65.859 174.797 1869.821
First year expected costs for a school garden with STEM education:
summary(garden_simulation_results$y$Cashflow_garden_STEM1)
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## -943.72 -237.06 -121.76 -77.60 44.09 1772.05
Cash flow plots of the garden option without formal STEM education. These are the expected returns for public and private schools over the intervention.
# Cashflow of the garden option without formal STEM education
# This will be the cost for public and private schools over the intervention.
source("functions/plot_cashflow.R")
plot_cashflow_garden <- plot_cashflow(mcSimulation_object = garden_simulation_results,
cashflow_var_name = "Cashflow_garden",
facet_labels = "Passive garden") +
theme(legend.position = "none", axis.title.y = element_blank(),
axis.title.x = element_blank(),
axis.text.x = element_blank(),
axis.ticks = element_blank())
# Cashflow of the garden option with formal STEM education
source("functions/plot_cashflow.R")
plot_cashflow_STEM <- plot_cashflow(mcSimulation_object = garden_simulation_results,
cashflow_var_name = "Cashflow_garden_STEM",
facet_labels = "STEM garden")+
labs(y = "Cashflow (million VND)")
# # manually share axis label (not a feature of patchwork)
#
# ylab <- plot_cashflow_garden$labels$y
# plot_cashflow_garden$labels$y <- plot_cashflow_STEM$labels$y <- " "
#
# h_patch <- plot_cashflow_garden / plot_cashflow_STEM
# # Use the tag label as a y-axis label
# wrap_elements(h_patch) +
# labs(tag = "Cashflow") +
# theme(
# plot.tag = element_text(size = rel(1), angle = 90),
# plot.tag.position = "left"
# )
plot_cashflow_garden / plot_cashflow_STEM
ggsave("figures/Fig_6_cashflow.png", width=5, height=5)
We use Projection to Latent Structures (PLS) model to assess the
correlation strength and direction for model variables and outcome
variables. The Partial Least Squares is fitted with the orthogonal
scores algorithm with pls::plsr.
PLS for private schools:
# For passive education garden option
source("functions/pls_model.R")
pls_result <- pls_model(object = garden_simulation_results,
resultName = names(garden_simulation_results$y)[1], # the "NPV_garden_inclusive"
ncomp = 1)
# read in the common input table
input_table <- read.csv("data/inputs_school_garden.csv")
label_private_school <- "Private school"
# source the plot function
source("functions/plot_pls.R")
plot_pls_garden <- plot_pls(plsrResults = pls_result,
input_table = input_table,
threshold = 0.9) +
theme(legend.position = "none", axis.title.x = element_blank(),
axis.text.x = element_blank(),
axis.ticks = element_blank()) + scale_x_continuous(limits = c(0, 7)) + ggtitle(label_private_school) +
annotate(geom="text", x=5, y=1, label="Passive garden")
## Scale for x is already present.
## Adding another scale for x, which will replace the existing scale.
#For school garden with formal STEM education
pls_result_STEM <- pls_model(object = garden_simulation_results,
resultName = names(garden_simulation_results$y)[2], # the "NPV_garden_STEM"
ncomp = 1)
plot_pls_STEM <- plot_pls(plsrResults = pls_result_STEM,
input_table = input_table,
threshold = 0.9) +
scale_x_continuous(limits = c(0, 7)) +
annotate(geom="text", x=5, y=1, label="STEM garden")
## Scale for x is already present.
## Adding another scale for x, which will replace the existing scale.
plot_pls_garden / plot_pls_STEM
Garden options for private schools:
source("functions/pls_posthoc.R")
pls_posthoc(plsrResults = pls_result, threshold = 0.9)
## Data: X dimension: 10000 75
## Y dimension: 10000 1
## Fit method: oscorespls
## Number of components considered: 1
## TRAINING: % variance explained
## 1 comps
## X 1.362
## y 81.550
## Data: X dimension: 10000 75
## Y dimension: 10000 1
## Fit method: oscorespls
## Number of components considered: 1
## TRAINING: % variance explained
## 1 comps
## X 1.362
## y 81.550
## Data: X dimension: 10000 75
## Y dimension: 10000 1
## Fit method: oscorespls
## Number of components considered: 1
## TRAINING: % variance explained
## 1 comps
## X 1.362
## y 81.550
## PLS Model Summary:
## Number of Components: 1
## R-squared Value for Y:
## % Variance Explained in X:
## % Variance Explained in Y:
##
## Important Variables (VIP > 0.9):
## Variable
## if_community_likes if_community_likes
## garden_mental_health_value garden_mental_health_value
## child_garden_health_care_savings child_garden_health_care_savings
## child_garden_school_performance_value child_garden_school_performance_value
## school_event_value school_event_value
## school_event_freq school_event_freq
## VIP Coefficient
## if_community_likes 3.5792283 483.3609
## garden_mental_health_value 1.8078520 244.1434
## child_garden_health_care_savings 3.0931584 417.7190
## child_garden_school_performance_value 0.9011608 121.6983
## school_event_value 6.0637930 818.8917
## school_event_freq 2.9659178 400.5357
## $plsrResults
## Partial least squares regression, fitted with the orthogonal scores algorithm.
## Call:
## plsr(formula = y ~ x, ncomp = ncomp, method = "oscorespls", scale = scale)
##
## $r_squared
## NULL
##
## $explained_variance_x
## NULL
##
## $explained_variance_y
## NULL
##
## $important_vars
## Variable
## if_community_likes if_community_likes
## garden_mental_health_value garden_mental_health_value
## child_garden_health_care_savings child_garden_health_care_savings
## child_garden_school_performance_value child_garden_school_performance_value
## school_event_value school_event_value
## school_event_freq school_event_freq
## VIP Coefficient
## if_community_likes 3.5792283 483.3609
## garden_mental_health_value 1.8078520 244.1434
## child_garden_health_care_savings 3.0931584 417.7190
## child_garden_school_performance_value 0.9011608 121.6983
## school_event_value 6.0637930 818.8917
## school_event_freq 2.9659178 400.5357
STEM options for private schools:
pls_posthoc(plsrResults = pls_result_STEM, threshold = 0.9)
## Data: X dimension: 10000 75
## Y dimension: 10000 1
## Fit method: oscorespls
## Number of components considered: 1
## TRAINING: % variance explained
## 1 comps
## X 1.364
## y 75.237
## Data: X dimension: 10000 75
## Y dimension: 10000 1
## Fit method: oscorespls
## Number of components considered: 1
## TRAINING: % variance explained
## 1 comps
## X 1.364
## y 75.237
## Data: X dimension: 10000 75
## Y dimension: 10000 1
## Fit method: oscorespls
## Number of components considered: 1
## TRAINING: % variance explained
## 1 comps
## X 1.364
## y 75.237
## PLS Model Summary:
## Number of Components: 1
## R-squared Value for Y:
## % Variance Explained in X:
## % Variance Explained in Y:
##
## Important Variables (VIP > 0.9):
## Variable
## if_community_likes if_community_likes
## annual_teacher_training annual_teacher_training
## garden_mental_health_value garden_mental_health_value
## child_STEM_community_engagement_value child_STEM_community_engagement_value
## school_event_value school_event_value
## school_event_freq school_event_freq
## VIP Coefficient
## if_community_likes 3.623407 486.4791
## annual_teacher_training 2.699158 -362.3893
## garden_mental_health_value 1.776662 238.5348
## child_STEM_community_engagement_value 1.317011 176.8220
## school_event_value 6.120904 821.7933
## school_event_freq 2.935882 394.1719
## $plsrResults
## Partial least squares regression, fitted with the orthogonal scores algorithm.
## Call:
## plsr(formula = y ~ x, ncomp = ncomp, method = "oscorespls", scale = scale)
##
## $r_squared
## NULL
##
## $explained_variance_x
## NULL
##
## $explained_variance_y
## NULL
##
## $important_vars
## Variable
## if_community_likes if_community_likes
## annual_teacher_training annual_teacher_training
## garden_mental_health_value garden_mental_health_value
## child_STEM_community_engagement_value child_STEM_community_engagement_value
## school_event_value school_event_value
## school_event_freq school_event_freq
## VIP Coefficient
## if_community_likes 3.623407 486.4791
## annual_teacher_training 2.699158 -362.3893
## garden_mental_health_value 1.776662 238.5348
## child_STEM_community_engagement_value 1.317011 176.8220
## school_event_value 6.120904 821.7933
## school_event_freq 2.935882 394.1719
# For passive education garden option
source("functions/pls_model.R")
pls_result_garden_public <- pls_model(object = garden_simulation_results,
resultName = names(garden_simulation_results$y)[3],
# "NPV_garden_public_school"
ncomp = 1)
# read in the common input table
input_table <- read.csv("data/inputs_school_garden.csv")
label_public_school <- "Public school"
# source the plot function
source("functions/plot_pls.R")
plot_pls_garden_public <- plot_pls(pls_result_garden_public,
input_table = input_table, threshold = 0.9) +
theme(legend.position = "none", axis.title.x = element_blank(),
axis.text.x = element_blank(),
axis.ticks = element_blank()) +
scale_x_continuous(limits = c(0, 7)) + ggtitle(label_public_school) +
annotate(geom="text", x=5, y=1, label="Passive garden")
## Scale for x is already present.
## Adding another scale for x, which will replace the existing scale.
#For school garden with formal STEM education
pls_result_STEM_public <- pls_model(object = garden_simulation_results,
resultName = names(garden_simulation_results$y)[4],
# "NPV_garden_STEM_public_school"
ncomp = 1)
plot_pls_public_STEM <- plot_pls(pls_result_STEM_public,
input_table = input_table, threshold = 0.9) + scale_x_continuous(limits = c(0, 7)) +
annotate(geom="text", x=5, y=1, label="STEM garden")
## Scale for x is already present.
## Adding another scale for x, which will replace the existing scale.
plot_pls_garden_public / plot_pls_public_STEM
Garden option in public school:
pls_posthoc(plsrResults = pls_result_garden_public, threshold = 0.9)
## Data: X dimension: 10000 75
## Y dimension: 10000 1
## Fit method: oscorespls
## Number of components considered: 1
## TRAINING: % variance explained
## 1 comps
## X 1.371
## y 34.692
## Data: X dimension: 10000 75
## Y dimension: 10000 1
## Fit method: oscorespls
## Number of components considered: 1
## TRAINING: % variance explained
## 1 comps
## X 1.371
## y 34.692
## Data: X dimension: 10000 75
## Y dimension: 10000 1
## Fit method: oscorespls
## Number of components considered: 1
## TRAINING: % variance explained
## 1 comps
## X 1.371
## y 34.692
## PLS Model Summary:
## Number of Components: 1
## R-squared Value for Y:
## % Variance Explained in X:
## % Variance Explained in Y:
##
## Important Variables (VIP > 0.9):
## Variable VIP
## if_community_likes if_community_likes 3.222189
## garden_mental_health_value garden_mental_health_value 1.654486
## child_garden_health_care_savings child_garden_health_care_savings 2.670497
## school_event_value school_event_value 5.741691
## school_event_freq school_event_freq 2.817428
## suitability_of_land_for_garden suitability_of_land_for_garden 1.797024
## beurocratic_barriers beurocratic_barriers 2.488932
## Coefficient
## if_community_likes 292.2914
## garden_mental_health_value 150.0819
## child_garden_health_care_savings 242.2463
## school_event_value 520.8408
## school_event_freq 255.5748
## suitability_of_land_for_garden 163.0118
## beurocratic_barriers -225.7762
## $plsrResults
## Partial least squares regression, fitted with the orthogonal scores algorithm.
## Call:
## plsr(formula = y ~ x, ncomp = ncomp, method = "oscorespls", scale = scale)
##
## $r_squared
## NULL
##
## $explained_variance_x
## NULL
##
## $explained_variance_y
## NULL
##
## $important_vars
## Variable VIP
## if_community_likes if_community_likes 3.222189
## garden_mental_health_value garden_mental_health_value 1.654486
## child_garden_health_care_savings child_garden_health_care_savings 2.670497
## school_event_value school_event_value 5.741691
## school_event_freq school_event_freq 2.817428
## suitability_of_land_for_garden suitability_of_land_for_garden 1.797024
## beurocratic_barriers beurocratic_barriers 2.488932
## Coefficient
## if_community_likes 292.2914
## garden_mental_health_value 150.0819
## child_garden_health_care_savings 242.2463
## school_event_value 520.8408
## school_event_freq 255.5748
## suitability_of_land_for_garden 163.0118
## beurocratic_barriers -225.7762
STEM option in public school:
pls_posthoc(plsrResults = pls_result_STEM_public, threshold = 0.9)
## Data: X dimension: 10000 75
## Y dimension: 10000 1
## Fit method: oscorespls
## Number of components considered: 1
## TRAINING: % variance explained
## 1 comps
## X 1.361
## y 45.117
## Data: X dimension: 10000 75
## Y dimension: 10000 1
## Fit method: oscorespls
## Number of components considered: 1
## TRAINING: % variance explained
## 1 comps
## X 1.361
## y 45.117
## Data: X dimension: 10000 75
## Y dimension: 10000 1
## Fit method: oscorespls
## Number of components considered: 1
## TRAINING: % variance explained
## 1 comps
## X 1.361
## y 45.117
## PLS Model Summary:
## Number of Components: 1
## R-squared Value for Y:
## % Variance Explained in X:
## % Variance Explained in Y:
##
## Important Variables (VIP > 0.9):
## Variable
## if_community_likes if_community_likes
## annual_teacher_training annual_teacher_training
## garden_mental_health_value garden_mental_health_value
## child_STEM_community_engagement_value child_STEM_community_engagement_value
## school_event_value school_event_value
## school_event_freq school_event_freq
## suitability_of_land_for_garden suitability_of_land_for_garden
## beurocratic_barriers beurocratic_barriers
## VIP Coefficient
## if_community_likes 3.352871 303.19595
## annual_teacher_training 3.323785 -300.56570
## garden_mental_health_value 1.649034 149.12007
## child_STEM_community_engagement_value 1.233191 111.51589
## school_event_value 5.835963 527.73884
## school_event_freq 2.776369 251.06362
## suitability_of_land_for_garden 1.000465 90.47077
## beurocratic_barriers 1.433234 -129.60556
## $plsrResults
## Partial least squares regression, fitted with the orthogonal scores algorithm.
## Call:
## plsr(formula = y ~ x, ncomp = ncomp, method = "oscorespls", scale = scale)
##
## $r_squared
## NULL
##
## $explained_variance_x
## NULL
##
## $explained_variance_y
## NULL
##
## $important_vars
## Variable
## if_community_likes if_community_likes
## annual_teacher_training annual_teacher_training
## garden_mental_health_value garden_mental_health_value
## child_STEM_community_engagement_value child_STEM_community_engagement_value
## school_event_value school_event_value
## school_event_freq school_event_freq
## suitability_of_land_for_garden suitability_of_land_for_garden
## beurocratic_barriers beurocratic_barriers
## VIP Coefficient
## if_community_likes 3.352871 303.19595
## annual_teacher_training 3.323785 -300.56570
## garden_mental_health_value 1.649034 149.12007
## child_STEM_community_engagement_value 1.233191 111.51589
## school_event_value 5.835963 527.73884
## school_event_freq 2.776369 251.06362
## suitability_of_land_for_garden 1.000465 90.47077
## beurocratic_barriers 1.433234 -129.60556
Here we assess value of information with the multi_EVPI
function. We calculate value of information in the form of Expected
Value of Perfect Information (EVPI).
# Subset the outputs from the mcSimulation function (y) by selecting the correct variables be sure to run the multi_EVPI only on the variables that we want. Find them with names(garden_simulation_results$y)
mcSimulation_table <- data.frame(garden_simulation_results$x,
garden_simulation_results$y[1:4])
# List of NPV variables to move to the last position (calculate 4 EVPIs only)
npvs_to_move <- c("NPV_garden_inclusive", "NPV_garden_STEM_inclusive",
"NPV_garden_public_school_inclusive", "NPV_garden_STEM_public_school_inclusive")
# Move NPV variables to the last position
mcSimulation_table <- mcSimulation_table %>% select(-all_of(npvs_to_move), all_of(npvs_to_move))
Calculate EVPI:
source("functions/multi_EVPI_test.R")
# evpi <- multi_EVPI_test(mc = mcSimulation_table, first_out_var = "NPV_garden_inclusive")
# save as a local .csv (takes ~ 15 minutes to run this)
# save(evpi,file="data/data_evpi.Rda")
load("data/data_evpi.Rda")
# open from saved file (last model run) - it is stable result / takes very long to run
EVPI for private schools:
#Value of information the garden intervention decision
source("functions/plot_evpi.R")
#plot_evpi_garden <- plot_evpi(EVPIresults = evpi,
# decision_vars = "NPV_garden_inclusive",
# new_names = "Garden",
# input_table = input_table,
# threshold = 10) +
# theme(legend.position = "none", axis.title.x = element_blank(),
# axis.text.x = element_blank(),
# axis.ticks = element_blank()) +
# scale_x_continuous(limits = c(0, 210)) + ggtitle(label_private_school)
# Value of information for the garden option with formal STEM education.
# using the results of the same multi_EVPI
# plot_evpi_STEM <- plot_evpi(EVPIresults = evpi,
# decision_vars = "NPV_garden_STEM_inclusive",
# new_names = "STEM garden",
# input_table = input_table,
# threshold = 10) + scale_x_continuous(limits = c(0, 210))
# plot_evpi_garden / plot_evpi_STEM
EVPI for public schools:
# Value of information for the public school garden option with no formal STEM education.
# using the results of the same multi_EVPI
# plot_evpi_public <- plot_evpi(evpi, decision_vars = "NPV_garden_public_school_inclusive",
# new_names = "Garden",
# input_table = input_table,
# threshold = 10) +
# theme(legend.position = "none", axis.title.x = element_blank(),
# axis.text.x = element_blank(),
# axis.ticks = element_blank()) +
# scale_x_continuous(limits = c(0, 210)) + ggtitle(label_public_school) #210
# Value of information for the public school garden option with formal STEM education.
# using the results of the same multi_EVPI
plot_evpi_public_STEM <- plot_evpi(evpi, decision_vars = "NPV_garden_STEM_public_school_inclusive",
new_names = "STEM garden",
input_table = input_table,
threshold = 10) # +
# scale_x_continuous(limits = c(0, 210)) #210
plot_evpi_public_STEM
# plot_evpi_public / plot_evpi_public_STEM
Our Pareto-optimal solutions represent the best trade-offs among the objectives of biodiversity, child health, and economic return. By focusing on these Pareto-optimal points, the analysis highlights solutions where improvements in one objective cannot be achieved without some compromise in at least one other.
source("pareto/plot_pareto_scenarios.R")
##
## Attaching package: 'gridExtra'
## The following object is masked from 'package:dplyr':
##
## combine
## Warning: `aes_string()` was deprecated in ggplot2 3.0.0.
## ℹ Please use tidy evaluation idioms with `aes()`.
## ℹ See also `vignette("ggplot2-in-packages")` for more information.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.
## Warning in get_plot_component(plot, "guide-box"): Multiple components found;
## returning the first one. To return all, use `return_all = TRUE`.
final_plot
# Save the plot
ggsave("figures/Fig_8_pareto_fronts.png", final_plot, width = 10, height = 8, bg = "white")
Controllable variables included:
estimates = read.csv("data/inputs_school_garden.csv")
estimates = estimates[estimates$variable !="", ]
estimates[estimates$control_status == "controllable", ]
## variable lower median upper distribution
## 1 number_of_years 5.0 NA 5.0 const
## 6 size_of_garden 5.0 NA 100.0 posnorm
## 13 if_effective_manage 0.5 NA 0.7 tnorm_0_1
## 17 if_effective_teaching 0.2 NA 0.9 tnorm_0_1
## 18 if_effective_training 0.2 NA 0.8 tnorm_0_1
## 23 if_animals_in_garden 0.2 NA 0.8 tnorm_0_1
## 49 if_school_has_canteen 0.2 NA 0.5 tnorm_0_1
## 85 school_event_freq 3.0 NA 10.0 posnorm
## 88 if_parking 0.1 NA 0.8 tnorm_0_1
## label control_status
## 1 Number of years for garden simulation controllable
## 6 Size of school garden in (m2) controllable
## 13 Chance of effective garden management (%) controllable
## 17 Chance of high education quality / effectiveness (%) controllable
## 18 Chance of effective training for teachers (%) controllable
## 23 Chance of school choosing to integrate animals in garden (%) controllable
## 49 Chance that the school has a canteen (%) controllable
## 85 Number of school events per year (days/year) controllable
## 88 Chance of including parking on the plot without a garden (%) controllable
Variables that are considered out of the control of the decision maker included:
estimates[estimates$control_status != "controllable", ]
## variable lower median upper distribution
## 2 discount_rate 3.000 NA 8.00 posnorm
## 3 CV_value 0.100 NA 0.40 tnorm_0_1
## 4 inflation_rate 5.000 NA 10.00 posnorm
## 7 expensive_garden_size 80.000 NA 95.00 posnorm
## 8 cost_increase_expensive_garden_size 1.010 NA 2.50 posnorm
## 10 if_students_like 0.500 NA 0.80 tnorm_0_1
## 11 if_parents_like 0.500 NA 0.90 tnorm_0_1
## 12 if_community_likes 0.100 NA 0.85 tnorm_0_1
## 14 if_garden_yield_enough 0.300 NA 0.80 tnorm_0_1
## 15 if_garden_healthy 0.500 NA 0.90 tnorm_0_1
## 16 if_teachers_like 0.200 NA 0.90 tnorm_0_1
## 19 if_offer_green_space 0.500 NA 0.90 tnorm_0_1
## 20 if_reduce_pollution 0.200 NA 0.50 tnorm_0_1
## 21 if_biophysical_good 0.200 NA 0.80 tnorm_0_1
## 25 equipment_cost 6.000 NA 20.00 posnorm
## 26 construction_cost 6.500 NA 130.50 posnorm
## 27 garden_designing_costs 10.000 NA 15.00 posnorm
## 28 teacher_training_cost 5.000 NA 20.00 posnorm
## 29 school_board_planning 6.000 NA 12.00 posnorm
## 30 teaching_equipment 5.000 NA 10.00 posnorm
## 31 compost_starting 5.000 NA 10.00 posnorm
## 32 worm_starting 3.000 NA 10.00 posnorm
## 33 livestock_establishment_costs 5.000 NA 25.00 posnorm
## 34 fishpond_cost 7.000 NA 10.00 posnorm
## 36 if_family_pays_establishment 0.200 NA 0.50 tnorm_0_1
## 37 establishment_family_portion_paid 0.200 NA 0.80 tnorm_0_1
## 39 maintaining_labor 25.000 NA 40.00 posnorm
## 40 teacher_salary_cost 20.000 NA 30.00 posnorm
## 41 teaching_equipment_annual 1.000 NA 40.00 posnorm
## 42 teaching_tools 2.000 NA 10.00 posnorm
## 43 seed_costs 5.000 NA 20.00 posnorm
## 44 fertilizer 1.000 NA 2.00 posnorm
## 45 plant_protection 2.000 NA 5.00 posnorm
## 46 livestock_maint 2.000 NA 10.00 posnorm
## 47 annual_teacher_training 5.000 NA 276.00 posnorm
## 50 canteen_savings 1.000 NA 5.00 posnorm
## 51 sale_of_yield 10.000 NA 30.00 posnorm
## 53 extra_cirricular_savings 20.000 NA 100.00 posnorm
## 54 formal_edu_savings 1.000 NA 3.00 posnorm
## 55 formal_edu_savings_STEM 20.000 NA 100.00 posnorm
## 57 outside_investment_value 1.000 NA 5.00 posnorm
## 58 outside_investment_value_STEM 1.000 NA 8.00 posnorm
## 60 increased_enrollment_value 0.100 NA 5.00 posnorm
## 61 increased_enrollment_value_STEM 10.000 NA 100.00 posnorm
## 63 child_veg_health_care_savings 0.100 NA 5.00 posnorm
## 64 child_veg_school_performance_value 0.010 NA 0.20 posnorm
## 65 child_veg_community_engagement_value 0.010 NA 0.10 posnorm
## 67 garden_mental_health_value 4.000 NA 300.00 posnorm
## 69 child_garden_health_care_savings 9.000 NA 500.00 posnorm
## 70 child_garden_school_performance_value 21.000 NA 182.00 posnorm
## 71 child_garden_community_engagement_value 3.000 NA 7.00 posnorm
## 73 child_STEM_health_care_savings 20.000 NA 80.00 posnorm
## 74 child_STEM_school_performance_value 2.000 NA 100.00 posnorm
## 75 child_STEM_community_engagement_value 10.000 NA 250.00 posnorm
## 77 green_space_eco_value 1.000 NA 10.00 posnorm
## 78 reduce_pollution_value 1.000 NA 3.00 posnorm
## 79 chance_garden_is_fallow_green_space 0.001 NA 0.05 tnorm_0_1
## 80 fallow_eco_reduction 0.500 NA 0.80 tnorm_0_1
## 81 green_space_health_value 1.000 NA 10.00 posnorm
## 82 fallow_health_reduction 0.500 NA 0.80 tnorm_0_1
## 84 school_event_value 10.000 NA 200.00 posnorm
## 87 value_of_non_garden_land_use 20.000 NA 50.00 posnorm
## 89 parking_value 0.100 NA 3.00 posnorm
## 90 costs_of_non_garden_land_use 1.000 NA 5.00 posnorm
## 92 land_access 0.600 NA 0.95 tnorm_0_1
## 93 suitability_of_land_for_garden 0.600 NA 0.95 tnorm_0_1
## 94 beurocratic_barriers 0.010 NA 0.50 tnorm_0_1
## label
## 2 Discounting factor
## 3 Coefficient of variation for our school garden intervention (%)
## 4 Inflation rate (%)
## 7 Cut off value for where the garden becomes more expensive (m2)
## 8 Percentage more expensive if garden is beyond the expensive_garden_size
## 10 Chance of student engagement (%)
## 11 Chance of parents support / effectiveness (%)
## 12 Chance of community support (%)
## 14 Chance of sufficient yield from garden (%)
## 15 Chance of healthy food from garden (%)
## 16 Chance of teacher engagement (%)
## 19 Chance of garden having ecologically valuable green space (%)
## 20 Chance of garden reducing polution (%)
## 21 Chance of biophysical not damaging (i.e. weather) (%)
## 25 Costs of equipment for setting up garden (million VND)
## 26 Costs of construction for setting up garden (million VND)
## 27 Costs of design team consultant (million VND)
## 28 Costs of training teachers when setting up garden (million VND)
## 29 Costs of planning meetings (million VND)
## 30 Equipment for teaching (million VND)
## 31 Starting compost (million VND)
## 32 Starting worms for compost (million VND)
## 33 Starting animals in the garden (million VND)
## 34 Digging a fish pond in the garden (million VND)
## 36 Chance that families donate to establishment (%)
## 37 Portion of establishment costs donated by families (%)
## 39 Annual Labor cost to maintain school garden (million VND/yr)
## 40 Additional teacher salary costs (million VND/yr)
## 41 Teaching equipment / manitaining microscopes etc. (million VND/yr)
## 42 Teaching tools / paper etc. (million VND/yr)
## 43 Seeds and seedlings (million VND/yr)
## 44 Fertilizer i.e. EM to add to compost (million VND/yr)
## 45 Integrated Pest Managemernt (IPM) (million VND/yr)
## 46 Mainitaining animals (million VND/yr)
## 47 Mainitaining teacher training (million VND/yr)
## 50 Canteen savings (million VND/yr)
## 51 Sales of garden products (million VND/yr)
## 53 Savings from extra-cirriclar activities (million VND/year)
## 54 Savings on formal education costs (no STEM garden) (million VND/year)
## 55 Savings on STEM formal education costs (million VND/year)
## 57 Outside investment value (reputation) garden (million VND/year)
## 58 Outside investment value (reputation) STEM (million VND/year)
## 60 Increased enrollment/tuition income (reputation) garden (million VND/year)
## 61 Increased enrollment/tuition income (reputation) STEM (million VND/year)
## 63 Healthcare savings (child) access to garden (million VND/year)
## 64 School performance (children) eating garden veg (million VND/year)
## 65 Community engagement (children) eating garden veg (million VND/year)
## 67 Mental health value of children/others having a garden at school (million VND/year)
## 69 Healthcare savings (children) with garden (million VND/year)
## 70 School performance value (children) with garden (million VND/year)
## 71 Community engagement value (children) with garden (million VND/year)
## 73 Healthcare savings (children) STEM garden (million VND/year)
## 74 School performance value (children) STEM garden (million VND/year)
## 75 Community engagement value (children) STEM garden (million VND/year)
## 77 Value of green space (million VND/year)
## 78 Value of reduced polution on school garden (million VND/year)
## 79 Chance that the garden space is fallow green space (%)
## 80 Proportion of value of fallow greenspace compared to garden (%)
## 81 Value of non-garden green space for child health (million VND/year)
## 82 Proportion of value of fallow greenspace for child heatlh compared to garden (%)
## 84 Value of garden related school events (million VND/event)
## 87 Value of non garden land use, playground etc. (million VND/yr)
## 89 Above table value of parking (million VND/yr)
## 90 Cost of non garden land use (million VND/yr)
## 92 Chance that the school has acess to land (%)
## 93 Chance that the land at the school is suitable (%)
## 94 Chance that beurocratic barriers will inhibit the process (%)
## control_status
## 2 uncertain
## 3 uncertain
## 4 uncertain
## 7 uncertain
## 8 uncertain
## 10 uncertain
## 11 uncertain
## 12 uncertain
## 14 uncertain
## 15 uncertain
## 16 uncertain
## 19 uncertain
## 20 uncertain
## 21 uncertain
## 25 uncertain
## 26 uncertain
## 27 uncertain
## 28 uncertain
## 29 uncertain
## 30 uncertain
## 31 uncertain
## 32 uncertain
## 33 uncertain
## 34 uncertain
## 36 uncertain
## 37 uncertain
## 39 uncertain
## 40 uncertain
## 41 uncertain
## 42 uncertain
## 43 uncertain
## 44 uncertain
## 45 uncertain
## 46 uncertain
## 47 uncertain
## 50 uncertain
## 51 uncertain
## 53 uncertain
## 54 uncertain
## 55 uncertain
## 57 uncertain
## 58 uncertain
## 60 uncertain
## 61 uncertain
## 63 uncertain
## 64 uncertain
## 65 uncertain
## 67 uncertain
## 69 uncertain
## 70 uncertain
## 71 uncertain
## 73 uncertain
## 74 uncertain
## 75 uncertain
## 77 uncertain
## 78 uncertain
## 79 uncertain
## 80 uncertain
## 81 uncertain
## 82 uncertain
## 84 uncertain
## 87 uncertain
## 89 uncertain
## 90 uncertain
## 92 uncertain
## 93 uncertain
## 94 uncertain
An rmoo::summary of the values resulting from the
rmoo::nsga2 minimization of a fitness function using
non-dominated sorting genetic algorithms - II (NSGA-IIs). Multiobjective
evolutionary algorithms with 500 random draws with the
decisionSupport::random 200 100 a population size of 200
and 100 iterations (or ‘generations’ maxiter) in
rmoo::nsga2.
Load the results of a multi-objective optimization run with
load, including the fitness values and population of
solutions. Display the optimal results with rmoo::summary.
The final result@fitness contains the fitness values for
all solutions in the final generation of the optimization. The
rmoo:non_dominated_fronts() identifies which solutions are
Pareto-optimal. The sweep Filters the rescaled fitness
matrix mat to retain only the Pareto-optimal solutions
front1_set indices of Pareto-optimal solutions from
mat2 that includes only these Pareto-optimal solutions. For
example, if mat2 has 200 rows, but front1_set
contains 24 indices, set1 will be a 24×3 matrix.
load(file="data/optimization_results/private_nostem_500_200_100.RData")
# loads the previously saved result object from an .RData file.
rmoo::summary(result)
##
## Summary of NSGA-II run
## #====================================
## Number of Objectives evaluated: 3
## Total iterations: 100
## Population size: 200
## Nondominated points found: 200 (100% of total)
## Crowding distance bounds: Inf 0
## Mutation Probability: 10%
## Crossover Probability: 80%
##
## Please install package 'ecr' to calculate IGD and GD.
##
## Please install package 'emoa' to calculate hypervolume.
## #====================================
mat = result@fitness
front1_set = rmoo::non_dominated_fronts(result)$fit[[1]]
mat2 = sweep(-mat, 2, c(100, 1, 100) , `*`) # retransform
set1 = mat2[front1_set, ]
# Import from saved .RData (takes a long time to run)
load(file="data/optimization_results/private_stem_500_200_100.RData")
rmoo::summary(result)
##
## Summary of NSGA-II run
## #====================================
## Number of Objectives evaluated: 3
## Total iterations: 100
## Population size: 200
## Nondominated points found: 200 (100% of total)
## Crowding distance bounds: Inf 0
## Mutation Probability: 10%
## Crossover Probability: 80%
##
## Please install package 'ecr' to calculate IGD and GD.
##
## Please install package 'emoa' to calculate hypervolume.
## #====================================
mat = result@fitness
front1_set = rmoo::non_dominated_fronts(result)$fit[[1]]
mat2 = sweep(-mat, 2, c(100, 1, 100) , `*`) # retransform
set2_1 = mat2[front1_set, ]
set2 = set2_1[set2_1[, 1]>0, ]
df_results <- as.data.frame(sweep(-mat, 2, c(100, 1, 100), `*`))
colnames(df_results) <- c("Economic", "Biodiversity", "Health")
df_all_results <- as.data.frame(sweep(-mat, 2, c(100, 1, 100), `*`))
colnames(df_all_results) <- c("Economic", "Biodiversity", "Health")
# Plot all 600 solutions
ggplot(df_all_results, aes(x = Economic, y = Biodiversity)) +
geom_jitter(alpha = 0.5, color = "grey", width = 0.2, height = 0.2) + # Plot all points in grey
geom_point(data = df_results, aes(x = Economic, y = Biodiversity), color = "red") + # Highlight Pareto points in red
labs(title = "Economic vs Biodiversity Trade-off", x = "Economic", y = "Biodiversity") +
theme_minimal()
load(file="data/optimization_results/public_nostem_500_200_100.RData")
rmoo::summary(result)
##
## Summary of NSGA-II run
## #====================================
## Number of Objectives evaluated: 3
## Total iterations: 100
## Population size: 200
## Nondominated points found: 200 (100% of total)
## Crowding distance bounds: Inf 0
## Mutation Probability: 10%
## Crossover Probability: 80%
##
## Please install package 'ecr' to calculate IGD and GD.
##
## Please install package 'emoa' to calculate hypervolume.
## #====================================
mat = result@fitness
front1_set = rmoo::non_dominated_fronts(result)$fit[[1]]
mat2 = sweep(-mat, 2, c(100, 1, 100) , `*`) # retransform
set3 = mat2[front1_set, ]
load(file="data/optimization_results/public_stem_500_200_100.RData")
rmoo::summary(result)
##
## Summary of NSGA-II run
## #====================================
## Number of Objectives evaluated: 3
## Total iterations: 100
## Population size: 200
## Nondominated points found: 200 (100% of total)
## Crowding distance bounds: Inf 0
## Mutation Probability: 10%
## Crossover Probability: 80%
##
## Please install package 'ecr' to calculate IGD and GD.
##
## Please install package 'emoa' to calculate hypervolume.
## #====================================
mat = result@fitness
front1_set = rmoo::non_dominated_fronts(result)$fit[[1]]
mat2 = sweep(-mat, 2, c(100, 1, 100) , `*`) # retransform
set4 = mat2[front1_set, ]
# Plot Pareto results ####
library(plotly)
library(ggplot2)
library(cowplot)
##
## Attaching package: 'cowplot'
## The following object is masked from 'package:lubridate':
##
## stamp
## The following object is masked from 'package:patchwork':
##
## align_plots
## The following object is masked from 'package:gt':
##
## as_gtable
pareto_3d_plot <- plot_ly() %>%
add_trace(x = set1[,1], y = set1[,2], z = set1[,3],
type = "scatter3d", mode = "markers",
marker = list(color = 'blue', size = 5),
name = 'private, no STEM') %>%
add_trace(x = set2[,1], y = set2[,2], z = set2[,3],
type = "scatter3d", mode = "markers",
marker = list(color = 'red', size = 5),
name = 'private, STEM') %>%
add_trace(x = set3[,1], y = set3[,2], z = set3[,3],
type = "scatter3d", mode = "markers",
marker = list(color = 'green', size = 5),
name = 'public, no STEM') %>%
add_trace(x = set4[,1], y = set4[,2], z = set4[,3],
type = "scatter3d", mode = "markers",
marker = list(color = 'orange', size = 5),
name = 'public, STEM') %>%
layout(scene = list(xaxis = list(title = 'economic'),
yaxis = list(title = 'biodiversity'),
zaxis = list(title = 'health')))
# pareto_3d_plot
Here we provide a summary of the garden intervention options. We do
this with a summary table of the simulation results. We show the
percentage of missing values as well as the mean, median and standard
deviation (SD) for each output of our model simulations. We use the
gt_plt_summary() from {gtExtras} and with options from
{svglite}. The table shows the name, the plot overview as well as the
number of missing values, the mean, median and the standard deviation of
the distribution for all variables that were fed into the model from our
input table of uncertainty values.
# Subset the outputs from the mcSimulation function (y) to summarize only on the variables that we want.
# names(garden_simulation_results$x)
mcSimulation_table_x <- data.frame(garden_simulation_results$x[4:7]) #, 21:30, 32:41, 43:70, 73:76) also of possible interest
gtExtras::gt_plt_summary(mcSimulation_table_x)
| mcSimulation_table_x | ||||||
| 10000 rows x 4 cols | ||||||
| Column | Plot Overview | Missing | Mean | Median | SD | |
|---|---|---|---|---|---|---|
| inflation_rate | 0.0% | 7.5 | 7.5 | 1.5 | ||
| size_of_garden | 0.0% | 45.7 | 41.8 | 29.6 | ||
| expensive_garden_size | 0.0% | 87.4 | 87.5 | 4.5 | ||
| cost_increase_expensive_garden_size | 0.0% | 1.8 | 1.8 | 0.4 | ||
# a summary table with missing, mean, median and sd
The table shows the variable name, the plot overview as well as the number of missing values, the mean, median and the standard deviation of the distribution for variables that calculated in the model.
The full repository can be accessed at https://github.com/CWWhitney/urban_school_gardens